unit mssql;

//{$mode objfpc}{$H+}
{$DEFINE Delphi}
interface

uses
  Classes
  , SysUtils
  , DbEntities
  , db
  {$IFDEF FPC}
  , mssqlconn
  , sqldb
  {$ENDIF}
  {$IFDEF Delphi}
  , Data.Win.ADODB
  , ActiveX
  {$ENDIF}
  ;

type
  TMsSqlFieldType=
    (
      sftUnknown
      , sftTinyInt
      , sftSmallint
      , sftInt
      , sftSysname
      , sftVarchar
      , sftNVarchar
      , sftChar
      , sftNChar
      , sftBigint
      , sftBit
      , sftBinary
      , sftNBinary
      , sftText
      , sftNText
      , sftSmallDatetime
      , sftDate
      , sftTime
      , sftDatetime
      , sftDateTime2
      , sftDateTimeOffset
      , sftDecimal
      , sftFloat
      , sftSmallMoney
      , sftMoney
      , sftNumeric
      , sftVarBinary
      , sftXml
      , sftUniqueIdentifier
      , sftTimestamp
      , sftCustom
    );

const
  VARIABLE_LEN_FIELD_TYPES =
    [ sftVarchar, sftNVarchar, sftChar, sftNChar, sftBinary, sftVarBinary
      , sftDecimal, sftNumeric, sftDateTime2, sftDateTimeOffset, sftTime
    ];

type
  { TSqlColType }

  TSqlColType=class(TColType)
  private
    FType: TMsSqlFieldType;
  protected
    function GetType: Integer; override;
    procedure SetType(const AType: Integer); override;
    function GetName: string; override;
    procedure SetName(const AName: string); override;
    function GetIsVariableSize: Boolean; override;
    function GetHasPrecision: Boolean; override;
    function GetDefSize: Integer; override;

    property Type_: TMsSqlFieldType read FType write FType;
  end;

  TIdentity=class
    Seed: Int64;
    Increment: Integer;
  end;

  TMsSqlColumn=class(TDbColumn)
  private
    FIsIdentity: Boolean;
    FIdentity: TIdentity;
    FCollation: string;
    function GetIsIdentity: Boolean;
    procedure SetIsIdentity(const Value: Boolean);
    function GetColType: TSqlColType;
  protected
    function GetDDL: string; override;
    function GetCreateDDL: string; override;
    class function GetColTypeClass: TColTypeClass; override;
    function GetFullname: string; override;
  public
    constructor Create(ATable: TDbTable; const AName: string); override;
    destructor Destroy; override;

    property IsIdentity: Boolean read GetIsIdentity write SetIsIdentity;
    property Identity: TIdentity read FIdentity;
    property ColType: TSqlColType read GetColType;
    property Collation: string read FCollation write FCollation;
  end;

  { TMsSqlColumns }

  TMsSqlColumns=class(TDbColumns)
  private
    function GetItem(Index: Integer): TMsSqlColumn;
  protected
    class function EntityClass: TDbTableMemberClass; override;
  public
    function Add(const AName: string=''): TMsSqlColumn; overload;

    function Find(const AColName: string; var AColumn: TMsSqlColumn): Boolean;

    property Items[Index: Integer]: TMsSqlColumn read GetItem; default;
  end;

  TIndexCol=class(TDbEntity)
  private
    FIsAscending: Boolean;
  protected
    function GetDDL: string; override;
    function GetCreateDDL: string; override;
    function GetFullname: string; override;
  public
    constructor Create(const AName: string); override;

    property IsAscending: Boolean read FIsAscending write FIsAscending default True;
  end;

  TIndexCols=class(TDbEntities)
  protected
    function GetItem(Index: Integer): TIndexCol;
    class function EntityClass: TDbEntityClass; override;
  public
    procedure WriteDdlTo(AStrings: TStrings);
    property Items[Index: Integer]: TIndexCol read GetItem; default;
  end;

  TMsSqlIndex=class(TDbIndex)
  private
    FClustered: Boolean;
    FLocation: string;
  protected
    function GetDDL: string; override;
    function GetFullname: string; override;
  public
    property Clustered: Boolean read FClustered write FClustered;
    property Location: string read FLocation write FLocation;
  end;

  TMsSqlIndexes=class(TDbIndexes)
  protected
    function GetItem(AIndex: Integer): TMsSqlIndex;
    class function EntityClass: TDbTableMemberClass; override;
  public
    function Add(const AName: string): TMsSqlIndex; overload;

    property Items[Index: Integer]: TMsSqlIndex read GetItem; default;
  end;

  { TMsSqlTable }

  TMsSqlTable=class(TDbTable)
  private
    FId: Integer;
    FColumns: TMsSqlColumns;
    FForeignKeys: TDbForeignKeys;
    FOwner: string;
    FDataFilegroup: string;
    FIndexes: TMsSqlIndexes;
  protected
    function GetColumns: TDbColumns; override;
    function GetFullname: string; override;
    function GetCreateDDL: string; override;
    function GetDDL: string; override;
    function GetForeignKeys: TDbForeignKeys; override;

    property Columns: TMsSqlColumns read FColumns;
  public
    constructor Create(const AName: string); override;
    destructor Destroy; override;

    property Id: Integer read FId write FId;
    property Owner: string read FOwner write FOwner;
    property Indexes: TMsSqlIndexes read FIndexes;
    property DataFilegroup: string read FDataFilegroup write FDataFileGroup;
  end;

  { TMsSqlTables }

  TMsSqlTables=class(TDbTables)
  private
    function GetItem(Index: Integer): TMsSqlTable;
  protected
    class function EntityClass: TDbEntityClass; override;
  public
    function Add(const AName: string=''): TMsSqlTable; overload;

    property Items[Index: Integer]: TMsSqlTable read GetItem; default;
  end;

  { TMsSqlView }

  TMsSqlView=class(TDbView)
  private
    FId: Integer;
  public
    property Id: Integer read FId write FId;
  end;

  { TMsSqlViews }

  TMsSqlViews=class(TDbViews)
  protected
    class function EntityClass: TDbEntityClass; override;
    function GetItem(Index: Integer): TMsSqlView;
  public
    function Add(const AName: string=''): TMsSqlView;

    property Items[Index: Integer]: TMsSqlView read GetItem; default;
  end;

  TMsSqlUDF=class(TDbUDF)
  private
    FId: Integer;
  public
    property Id: Integer read FId write FId;
  end;

  { TMsSqlUDFs }

  TMsSqlUDFs=class(TDbUDFs)
  private
    function GetItem(Index: Integer): TMsSqlUDF;
  protected
    class function EntityClass: TDbEntityClass; override;
  public
    function Add(const AName: string): TMsSqlUDF; overload;

    property Items[Index: Integer]: TMsSqlUDF read GetItem; default;
  end;

  { TMsSqlProc }

  TMsSqlProc=class(TDbProc)
  private
    FId: Integer;
  public
    property Id: Integer read FId write FId;
  end;

  { TMsSqlProcs }

  TMsSqlProcs=class(TDbProcs)
  protected
    function GetItem(Index: integer): TMsSqlProc;
    class function EntityClass: TDbEntityClass; override;
  public
    function Add(const AProcName: string=''): TMsSqlProc; overload;
    property Items[Index: integer]: TMsSqlProc read GetItem; default;
  end;

  { TMsSqlDatabase }

  TMsSqlDatabase=class(TDbDatabase)
  private
    FTables: TMsSqlTables;
    FViews : TMsSqlViews;
    FUDFs  : TMsSqlUDFs;
    FProcs : TMsSqlProcs;
  protected
    function GetTables: TDbTables; override;
    function GetViews : TDbViews; override;
    function GetUDFs  : TDbUDFs; override;
    function GetProcs : TDbProcs; override;
  public
    constructor Create(const AName: string); override;
    destructor Destroy; override;

    property Tables: TMsSqlTables read FTables;
    property Views: TMsSqlViews read FViews;
    property Procs: TMsSqlProcs read FProcs;
    property UDFs : TMsSqlUDFs read FUDFs;
  end;

{$IFDEF Delphi}
  TSQLQuery=TADOQuery;
  TMSSQLConnection=TADOConnection;
{$ENDIF}

  { TSqlParser }

  TMsSqlParser=class(TDbParser)
  private
    Conn : TMSSQLConnection;
    {$IFDEF FPC}
    Trans: TSQLTransaction;
    {$ENDIF}
    Db   : TMsSqlDatabase;
  protected
    procedure GetUDFs;
    procedure GetViews;
    procedure GetProcs;
    procedure GetTables;
    procedure CompleteTableInfo(ATable: TMsSqlTable);

    procedure DoGetCreateDDLs(ATable: TMsSqlTable; ADest: TStrings;
      ADecorator: TLineDecorator); overload;
    procedure DoGetCreateDDLs(AIndex: TMsSqlIndex; ADest: TStrings;
      ADecorator: TLineDecorator); overload;

    procedure DoGetDropTableCmdOf(ATable: TMsSqlTable; ADest: TStrings;
      const AWithCheckExistence: Boolean; ADecorator: TLineDecorator);
    procedure DoGetTableCreateDDLs(ATable: TMsSqlTable; ADest: TStrings;
      ADecorator: TLineDecorator);
  public
    procedure GetDropTableCmdOf(ATable: TDbTable; ADest: TStrings;
      const AWithCheckExistence: Boolean=False); override;

    procedure Parse(const AOptions: TDbParsingOptions; ADbInfo: TDbHostInfo;
      var ADatabase: TDbDatabase); override;
    procedure GetCreateDDLs(ADatabase: TDbDatabase; ADest: TStrings;
      const APrefix: string=''); override;
    procedure GetCreateDDLs(ATable: TDbTable; ADest: TStrings;
      const APrefix: string = ''; const AIndent: string = ''); override;
  end;

  function ColTypeNameToType(AName: string): TMsSqlFieldType;

const
  CLUSTERED_NAMES: array[Boolean] of string =
    ('NONCLUSTERED', 'CLUSTERED');

implementation

var
  uMSSQL_COLTYPE_NAMES: array[TMsSqlFieldType] of string =
    (
      ''
      , 'tinyint'
      , 'smallint'
      , 'int'
      , 'sysname'
      , 'varchar'
      , 'nvarchar'
      , 'char'
      , 'nchar'
      , 'bigint'
      , 'bit'
      , 'binary'
      , 'nbinary'
      , 'text'
      , 'ntext'
      , 'smalldatetime'
      , 'date'
      , 'time'
      , 'datetime'
      , 'datetime2'
      , 'datetimeoffset'
      , 'decimal'
      , 'float'
      , 'smallmoney'
      , 'money'
      , 'numeric'
      , 'varninary'
      , 'xml'
      , 'uniqueidentifier'
      , 'timestamp'
      , 'custom'
    );

procedure BreakIf(const ACondition: Boolean);
begin
  if ACondition then
  asm
    INT 3;
  end;
end;

procedure InitMsSqlColTypeNames;
begin
  // this currently a stub. The plan is to use Rtti to fill the array of colum
  // type names (uMSSQL_COLTYPE_NAMES). Currently it is done manually.
end;

function ColTypeNameToType(AName: string): TMsSqlFieldType;
var
  i: TMsSqlFieldType;
begin
  Result := sftUnknown;
  AName := LowerCase(AName);
  for i := Succ(Low(TMsSqlFieldType)) to High(TMsSqlFieldType) do
    if uMSSQL_COLTYPE_NAMES[i]=AName then
    begin
      Result := i;
      Break;
    end;
end;

{ TMsSqlProcs }

function TMsSqlProcs.Add(const AProcName: string): TMsSqlProc;
begin
  Result := TMsSqlProc(inherited Add(AProcName));
end;

class function TMsSqlProcs.EntityClass: TDbEntityClass;
begin
  Result:=TMsSqlProc;
end;

function TMsSqlProcs.GetItem(Index: integer): TMsSqlProc;
begin
  Result := TMsSqlProc(inherited GetItem(Index));
end;

{ TMsSqlUDFs }

function TMsSqlUDFs.Add(const AName: string): TMsSqlUDF;
begin
  Result := TMsSqlUDF(inherited Add(AName));
end;

class function TMsSqlUDFs.EntityClass: TDbEntityClass;
begin
  Result:=TMsSqlUDF;
end;

function TMsSqlUDFs.GetItem(Index: Integer): TMsSqlUDF;
begin
  Result := TMsSqlUDF(inherited GetItem(Index));
end;

{ TMsSqlDatabase }

function TMsSqlDatabase.GetTables: TDbTables;
begin
  Result := FTables;
end;

function TMsSqlDatabase.GetViews: TDbViews;
begin
  Result := FViews;
end;

function TMsSqlDatabase.GetUDFs: TDbUDFs;
begin
  Result := FUDFs;
end;

function TMsSqlDatabase.GetProcs: TDbProcs;
begin
  Result := FProcs;
end;

constructor TMsSqlDatabase.Create(const AName: string);
begin
  inherited Create(AName);
  FTables := TMsSqlTables.Create(True);
  FViews  := TMsSqlViews.Create(True);
  FUDFs   := TMsSqlUDFs.Create(True);
  FProcs  := TMsSqlProcs.Create(True);
end;

destructor TMsSqlDatabase.Destroy;
begin
  FProcs.Free;
  FUDFs.Free;
  FViews.Free;
  FTables.Free;
  inherited Destroy;
end;

{ TSqlParser }

procedure TMsSqlParser.CompleteTableInfo(ATable: TMsSqlTable);
var
  i, j: Integer;
  s: string;
  T: OleVariant;
  L: TStringList;
  vCol: TMsSqlColumn;
  vCmd: TADOCommand;
  vIndex: TMsSqlIndex;
  vIndexCol: TDbIndexCol;
  vDataset: TADODataset;
begin
//  BreakIf(ATable.Name='Errors');
  vCmd := TADOCommand.Create(nil);
  try
    vDataset := TADODataset.Create(nil);
    try
      vCmd.Connection := Conn;
      vCmd.CommandType := cmdText;
      vCmd.CommandText := 'EXEC dbo.sp_help N''' + ATable.Name + '''';
      vDataset.Recordset := vCmd.Execute;

      ATable.Name  := vDataset.FieldByName('Name').AsString;
      ATable.Owner := vDataset.FieldByName('Owner').AsString;

      // get columns information
      vDataset.Recordset := vDataset.Recordset.NextRecordset(T);
      vDataset.First;
      while not vDataset.Eof do
      begin
        vCol := ATable.Columns.Add(vDataset.FieldByName('Column_name').AsString);
        vCol.ColType.Name := vDataset.FieldByName('Type').AsString;
        vCol.Size := vDataset.FieldByName('Length').AsInteger;
        vCol.Precision := StrToIntDef(Trim(vDataset.FieldByName('Prec').AsString), 0);
        vCol.IsNullable := vDataset.FieldByName('Nullable').AsBoolean;
        vCol.Collation  := vDataset.FieldByName('Collation').AsString;
        vDataset.Next;
      end;

      // get identity column(s) information
      vDataset.Recordset := vDataset.Recordset.NextRecordset(T);
      if not vDataset.IsEmpty then
      begin
        vDataset.First;
        while not vDataset.Eof do
        begin
          if ATable.Columns.Find(vDataset.FieldByName('Identity').AsString, vCol) then
          begin
            vCol.IsIdentity := True;
            vCol.Identity.Seed := vDataset.FieldByName('Seed').AsInteger;
            vCol.Identity.Increment := vDataset.FieldByName('Increment').AsInteger;
          end;
          vDataset.Next;
        end;
      end;

      // Get RowGuidCol information
      vDataset.Recordset := vDataset.Recordset.NextRecordset(T);
      if not vDataset.IsEmpty then
      begin

      end;

      // get data location in filegroup
      vDataset.Recordset := vDataset.Recordset.NextRecordset(T);
      if not vDataset.IsEmpty then
      begin
        ATable.DataFilegroup := vDataset.Fields[0].AsString;
      end;

      // Get indexes information
      vDataset.Recordset := vDataset.Recordset.NextRecordset(T);
      if not vDataset.IsEmpty then
      begin
        vIndex := ATable.Indexes.Add(vDataset.FieldByName('index_name').AsString);
        S := vDataset.FieldByName('index_description').AsString;
        i := Pos('located on ', S);
        if i > 0 then
        begin
          vIndex.Location := Copy(S, i+11, MaxInt);
          if i > 1 then
            Dec(i);
          Delete(s, i, MaxInt);
        end;

        // parse description
        i := Pos('nonclustered', S);
        vIndex.Clustered := i < 1;

        i := Pos('primary key', S);
        if i > 0 then
          vIndex.IndexType := itPrimary
        else begin
          i := Pos('unique key', s);
          if i > 0 then
            vIndex.IndexType := itUnique
          else
            vIndex.IndexType := itIndex;
        end;

        L := TStringList.Create;
        try
          L.CommaText := vDataset.FieldByName('index_keys').AsString;
          for i := 0 to L.Count-1 do
          begin
            S := Trim(L[i]);
            j := Pos('(-)', S);
            if j > 0 then
              Delete(S, j, MaxInt);

            vIndexCol := vIndex.Cols.Add(S);
            vIndexCol.IsAscending := j < 1;
          end;
        finally
          L.Free;
        end;
      end;

      // get constraints information
      vDataset.Recordset := vDataset.Recordset.NextRecordset(T);
      if not vDataset.IsEmpty then
      begin
      end;

    finally
      vDataset.Free;
    end;
  finally
    vCmd.Free;
  end;
end;

procedure TMsSqlParser.DoGetCreateDDLs(ATable: TMsSqlTable; ADest: TStrings;
  ADecorator: TLineDecorator);
var
  S: string;
  i: Integer;
  vMyDecorator: TLineDecorator;
begin
  ADest.BeginUpdate;
  try
    S := Format('CREATE TABLE [%s].[%s](', [ATable.Owner, ATable.Name]);
    ADest.Add(ADecorator.Decorate(S));
    ADecorator.Prefix := StringOfChar(' ', Length(ADecorator.Prefix));

    vMyDecorator.Setup('', '', ADecorator.CurrIndent+ADecorator.NextIndent, ADecorator.NextIndent);
    if ATable.Columns.Count > 0 then
    begin
      with ATable.Columns[0] do
        ADest.Add(vMyDecorator.Decorate(Format('[%s] %s %s', [Name, ColType.Name, NULLABLE_CODES[IsNullable]])));

      vMyDecorator.Prefix := ', ';
      vMyDecorator.CurrIndent := ADecorator.CurrIndent + ADecorator.NextIndent;
      for i := 1 to ATable.Columns.Count-1 do
        with ATable.Columns[i] do
          ADest.Add(vMyDecorator.Decorate(Format('[%s] %s %s', [Name, ColType.Name, NULLABLE_CODES[IsNullable]])));
    end;

    vMyDecorator.Prefix := '';
    vMyDecorator.CurrIndent := ADecorator.CurrIndent + ADecorator.NextIndent + '  ';
    for i := 0 to ATable.Indexes.Count-1 do
      if ATable.Indexes[i].IndexType in [itPrimary, itUnique] then
      begin
        DoGetCreateDDLs(ATable.Indexes[i], ADest, vMyDecorator);
        vMyDecorator.Prefix := ', ';
      end;

    ADest.Add(') ON [' + ATable.DataFilegroup + ']');

    ADecorator.Prefix := '';
    for i := 0 to ATable.Indexes.Count-1 do
      if ATable.Indexes[i].IndexType=itIndex then
        DoGetCreateDDLs(ATable.Indexes[i], ADest, ADecorator);

  finally
    ADest.EndUpdate;
  end;
end;

procedure TMsSqlParser.DoGetCreateDDLs(AIndex: TMsSqlIndex; ADest: TStrings;
  ADecorator: TLineDecorator);
var
  i: Integer;
  S: string;
  vMyDecorator: TLineDecorator;
begin
  ADest.BeginUpdate;
  try
    case AIndex.IndexType of
      itUnknown: Exit;
      itIndex  : S := Format('CREATE %s INDEX [%s] ON %s', [CLUSTERED_NAMES[AIndex.Clustered], AIndex.Name, AIndex.Table.Fullname]);
      itPrimary: S := Format('CONSTRAINT [%s] PRIMARY KEY %s', [AIndex.Name, CLUSTERED_NAMES[AIndex.Clustered]]);
      itUnique : S := Format('CONSTRAINT [%s] UNIQUE %s', [AIndex.Name, CLUSTERED_NAMES[AIndex.Clustered]]);
    end;

    ADest.Add(ADecorator.Decorate(S));
    ADest.Add(ADecorator.Decorate('('));
    if AIndex.Cols.Count > 0 then
    begin
      vMyDecorator.Setup(''
                         , ''
                         , ADecorator.CurrIndent + ADecorator.NextIndent
                         , ADecorator.NextIndent);

      S := '['+ AIndex.Cols[0].Name + '] ' + SORT_ORDER_CODES[AIndex.Cols[0].IsAscending];
      ADest.Add(vMyDecorator.Decorate(S));

      vMyDecorator.Prefix := ', ';
      vMyDecorator.CurrIndent := ADecorator.CurrIndent + ADecorator.NextIndent;
      for i := 1 to AIndex.Cols.Count-1 do
      begin
        S := '['+ AIndex.Cols[i].Name + '] ' + SORT_ORDER_CODES[AIndex.Cols[i].IsAscending];
        ADest.Add(vMyDecorator.Decorate(S));
      end;
    end;
    ADest.Add(ADecorator.Decorate(') ON [' + AIndex.Location + ']'));
  finally
    ADest.EndUpdate;
  end;
end;

procedure TMsSqlParser.DoGetDropTableCmdOf(ATable: TMsSqlTable;
  ADest: TStrings; const AWithCheckExistence: Boolean;
  ADecorator: TLineDecorator);
var
  S: string;
begin
  if AWithCheckExistence then
  begin
    S := Format('if exists (select * from dbo.sysobjects where id = object_id(N''[%s].[%s]'') and OBJECTPROPERTY(id, N''IsUserTable'') = 1)', [ATable.Owner, ATable.Name]);
    ADest.Add(ADecorator.Decorate(S));
    ADecorator.CurrIndent := ADecorator.CurrIndent + ADecorator.NextIndent;
  end;

  S := Format('drop table [%s].[%s]', [ATable.Owner, ATable.Name]);
  ADest.Add(ADecorator.Decorate(S));
end;

procedure TMsSqlParser.DoGetTableCreateDDLs(ATable: TMsSqlTable;
  ADest: TStrings; ADecorator: TLineDecorator);
begin

end;

procedure TMsSqlParser.GetCreateDDLs(ATable: TDbTable; ADest: TStrings;
  const APrefix, AIndent: string);
var
  vTable: TMsSqlTable absolute ATable;
  vMyDecorator: TLineDecorator;
begin
  if ATable is TMsSqlTable then
  begin
    vMyDecorator.Setup('', '', '', '	');
    DoGetDropTableCmdOf(vTable, ADest, True, vMyDecorator);
    ADest.Add('GO'#13#10);
    DoGetCreateDDLs(vTable, ADest, vMyDecorator);
  end;
end;

procedure TMsSqlParser.GetDropTableCmdOf(ATable: TDbTable; ADest: TStrings;
  const AWithCheckExistence: Boolean);
var
  vTable: TMsSqlTable absolute ATable;
  vDecorator: TLineDecorator;
begin
  if ATable is TMsSqlTable then
  begin
    vDecorator.Setup('', '', '', '');
    DoGetDropTableCmdOf(vTable, ADest, AWithCheckExistence, vDecorator);
  end;
end;

procedure TMsSqlParser.GetCreateDDLs(ADatabase: TDbDatabase; ADest: TStrings;
  const APrefix: string);
var
  i: Integer;
  vDb: TMsSqlDatabase absolute ADatabase;
begin
  for i := 0 to ADatabase.Tables.Count-1 do
  begin
    GetCreateDDLs(ADatabase.Tables[i], ADest);
  end;
end;

procedure TMsSqlParser.GetProcs;
var
  i: Integer;
  vQry    : TSQLQuery;
  vProc   : TMsSqlProc;
  vIdFld  : TField;
  vNameFld: TField;
begin
  vQry := TSQLQuery.Create(nil);
  try
    {$IFDEF FPC}
    vQry.Transaction := Trans;
    vQry.DataBase    := Conn;
    {$ENDIF}
    {$IFDEF Delphi}
    vQry.Connection := Conn;
    {$ENDIF}
    vQry.SQL.Text    := 'select [id], [name] from dbo.sysobjects where [type]=''P''';
    vQry.Open;

    vIdFld := vQry.Fields[0];
    vNameFld := vQry.Fields[1];
    if vNameFld=nil then
      Exit;

    vQry.First;
    while not vQry.EOF do
    begin
      vProc := Db.Procs.Add(vNameFld.AsString);
      vProc.Id := vIdFld.AsInteger;
      vQry.Next;
    end;

    // prepa
    vQry.Close;
    vQry.Prepared := True;
    vQry.SQL.Text := 'SELECT OBJECT_DEFINITION(:object_id)';

    for i := 0 to Db.Procs.Count-1 do
    begin
      vQry.Close;
      vQry.Parameters[0].Value := Db.Procs[i].Id;
      vQry.Open;
      Db.Procs[i].CreateDDL := vQry.Fields[0].AsString;
    end;
  finally
    vQry.Free;
  end;
end;

procedure TMsSqlParser.GetTables;
var
  i: Integer;
  vQry    : TSQLQuery;
  vTable  : TMsSqlTable;
  vNameFld: TField;
  vIdFld  : TField;
begin
  vQry := TSQLQuery.Create(nil);
  try
    {$IFDEF FPC}
    vQry.Transaction := Trans;
    vQry.DataBase    := Conn;
    {$ENDIF}
    {$IFDEF Delphi}
    vQry.Connection := Conn;
    {$ENDIF}
    vQry.SQL.Text    := 'select [id], [name] from dbo.sysobjects where [type]=''U''';
    vQry.Open;

    vIdFld := vQry.Fields[0];
    vNameFld := vQry.Fields[1];
    if vNameFld=nil then
      Exit;

    vQry.First;
    while not vQry.EOF do
    begin
      vTable := Db.Tables.Add(vNameFld.AsString);
      vTable.Id := vIdFld.AsInteger;
      vQry.Next;
    end;
  finally
    vQry.Free;
  end;

  for i := 0 to Db.Tables.Count-1 do
    CompleteTableInfo(Db.Tables[i]);
end;

procedure TMsSqlParser.GetUDFs;
var
  i: Integer;
  vQry    : TSQLQuery;
  vUDF    : TMsSqlUDF;
  vNameFld: TField;
  vIdFld  : TField;
begin
  vQry := TSQLQuery.Create(nil);
  try
    {$IFDEF FPC}
    vQry.Transaction := Trans;
    vQry.DataBase    := Conn;
    {$ENDIF}
    {$IFDEF Delphi}
    vQry.Connection := Conn;
    {$ENDIF}
    vQry.SQL.Text    := 'select [id], [name] from dbo.sysobjects where [type] in (''FN'', ''IF'', ''TF'')';
    vQry.Open;

    vIdFld := vQry.Fields[0];
    vNameFld := vQry.Fields[1];
    if vNameFld=nil then
      Exit;

    vQry.First;
    while not vQry.EOF do
    begin
      vUDF := Db.UDFs.Add(vNameFld.AsString);
      vUDF.Id := vIdFld.AsInteger;
      vQry.Next;
    end;

    // prepa
    vQry.Close;
    vQry.SQL.Text := 'SELECT OBJECT_DEFINITION(:object_id)';
    vQry.Prepared := True;

    for i := 0 to Db.UDFs.Count-1 do
    begin
      vQry.Close;
      vQry.Parameters[0].Value := Db.UDFs[i].Id;
      vQry.Open;
      Db.UDFs[i].CreateDDL := vQry.Fields[0].AsString;
    end;
  finally
    vQry.Free;
  end;
end;

procedure TMsSqlParser.GetViews;
var
  i: Integer;
  vQry    : TSQLQuery;
  vQryDDL : TSQLQuery;
  vView   : TMsSqlView;
  vNameFld: TField;
  vIdFld  : TField;
begin
  vQry := TSQLQuery.Create(nil);
  vQryDDL := TSQLQuery.Create(nil);
  try
    {$IFDEF FPC}
    vQryDDL.Transaction := Trans;
    vQryDDL.DataBase := Conn;
    vQry.Transaction := Trans;
    vQry.DataBase    := Conn;
    {$ENDIF}
    {$IFDEF Delphi}
    vQry.Connection := Conn;
    {$ENDIF}
    vQry.SQL.Text    := 'select [id], [name] from dbo.sysobjects where [type]=''V''';
    vQry.Open;

    vIdFld := vQry.Fields[0];
    vNameFld := vQry.Fields[1];
    if vNameFld=nil then
      Exit;

    vQry.First;
    while not vQry.EOF do
    begin
      vView := Db.Views.Add(vNameFld.AsString);
      vView.Id := vIdFld.AsInteger;
      vQry.Next;
    end;

    // prepa
    vQry.Close;
    vQry.SQL.Text := 'SELECT OBJECT_DEFINITION(:object_id)';
    vQry.Prepared := True;

    for i := 0 to Db.Views.Count-1 do
    begin
      vQry.Close;
      vQry.Parameters[0].Value := Db.Views[i].Id;
      vQry.Open;
      Db.Views[i].CreateDDL := vQry.Fields[0].AsString;
    end;
  finally
    vQryDDL.Free;
    vQry.Free;
  end;
end;

procedure TMsSqlParser.Parse(const AOptions: TDbParsingOptions;
  ADbInfo: TDbHostInfo; var ADatabase: TDbDatabase);
begin
  Db := TMsSqlDatabase.Create(ADbInfo.DbName);
  Conn := TMSSQLConnection.Create(nil);
  {$IFDEF FPC}
  Trans := TSQLTransaction.Create(nil);
  {$ENDIF}
  try
    {$IFDEF FPC}
    Trans.DataBase := Conn;
    Conn.HostName := ADbInfo.Host;
    Conn.DatabaseName := ADbInfo.DbName;
    Conn.UserName:=ADbInfo.UsrName;
    Conn.Password:=ADbInfo.UsrPass;
    {$ENDIF}
    {$IFDEF Delphi}
    Conn.ConnectionString := 'Provider=SQLOLEDB.1;'
                             + 'Password=' + ADbInfo.UsrPass + ';'
                             + 'Persist Security Info=True;'
                             + 'User ID=' + ADbInfo.UsrName + ';'
                             + 'Initial Catalog=' + ADbInfo.DbName + ';'
                             + 'Data Source=' + ADbInfo.Host + ';'
                             + 'Application Name=ddldump';
    {$ENDIF}

    Conn.LoginPrompt:=False;
    Conn.Open;

    GetTables;
    GetViews;
    GetProcs;
    GetUDFs;

  finally
    {$IFDEF FPC}
    Trans.Free;
    {$ENDIF}
    Conn.Free;
  end;
  ADatabase := Db;
end;

{ TMsSqlViews }

class function TMsSqlViews.EntityClass: TDbEntityClass;
begin
  Result:=TMsSqlView;
end;

function TMsSqlViews.GetItem(Index: Integer): TMsSqlView;
begin
  Result := TMsSqlView(inherited GetItem(Index));
end;

function TMsSqlViews.Add(const AName: string): TMsSqlView;
begin
  Result := TMsSqlView(inherited Add(AName));
end;

{ TMsSqlTables }

function TMsSqlTables.Add(const AName: string): TMsSqlTable;
begin
  Result := TMsSqlTable(inherited Add(AName));
end;

class function TMsSqlTables.EntityClass: TDbEntityClass;
begin
  Result:=TMsSqlTable;
end;

function TMsSqlTables.GetItem(Index: Integer): TMsSqlTable;
begin
  Result := TMsSqlTable(inherited GetItem(Index));
end;

{ TMsSqlTable }

constructor TMsSqlTable.Create(const AName: string);
begin
  inherited;
  FColumns := TMsSqlColumns.Create(Self, True);
  FIndexes := TMsSqlIndexes.Create(Self, True);
end;

destructor TMsSqlTable.Destroy;
begin
  FForeignKeys.Free;
  FIndexes.Free;
  FColumns.Free;
  inherited;
end;

function TMsSqlTable.GetColumns: TDbColumns;
begin
  Result := FColumns;
end;

function TMsSqlTable.GetCreateDDL: string;
var
  i: Integer;
  vCols: TStringList;
begin
  Result := GetDDL;
  Exit;
  Result := inherited GetCreateDDL;
  vCols := TStringList.Create;
  try
    for i := 0 to Indexes.Count-1 do
      Result := Result + #13#10 + Indexes[i].DDL;
  finally
    vCols.Free;
  end;

  if DataFilegroup<>'' then
    Result := Result + Format(' ON [%s]', [DataFilegroup]);
end;

function TMsSqlTable.GetDDL: string;

  procedure WriteName(T: TStrings);
  begin
    T.Add('CREATE TABLE ' + Fullname + '(');
  end;

  procedure WriteColumns(T: TStrings);
  var
    i: Integer;
  begin
    if Columns.Count > 0 then
      T.Add('	' + Columns[0].DDL);

    for i := 1 to Columns.Count-1 do
      T.Add('	, ' + Columns[i].DDL);
  end;

  procedure WriteConstraints(T: TStrings);
  var
    i, j: Integer;
  begin
    if Columns.Count > 0 then
      j := 0
    else begin
      j := Indexes.Count;
      for i := 0 to Indexes.Count-1 do
        if Indexes[i].IndexType in [itPrimary, itUnique] then
        begin
          T.Add('	' + Indexes[i].DDL);
          j := i+1;
          Break;
        end;
    end;

    for i := j to Indexes.Count-1 do
      if Indexes[i].IndexType in [itPrimary, itUnique] then
        T.Add('	, ' + Indexes[i].DDL);
  end;

  procedure WriteLocation(T: TStrings);
  begin
    T.Add(') ON ' + FDataFilegroup);
  end;

  procedure WriteIndexes(T: TStrings);
  var
    i: Integer;
  begin
    for i := 0 to Indexes.Count-1 do
      if Indexes[i].IndexType=itIndex then
        T.Add(Indexes[i].DDL);
  end;

var
  L: TStrings;
begin
  L := TStringList.Create;
  try
    WriteName(L);
    WriteColumns(L);
    WriteConstraints(L);
    WriteLocation(L);
    WriteIndexes(L);

    Result := L.Text;
  finally
    L.Free;
  end;
end;

function TMsSqlTable.GetForeignKeys: TDbForeignKeys;
begin
  if FForeignKeys=nil then
    FForeignKeys := TDbForeignKeys.Create(Self, True);
  Result := FForeignKeys;
end;

function TMsSqlTable.GetFullname: string;
begin
  if Owner<>'' then
    Result := Format('[%s].[%s]', [Owner, Name])
  else
    Result := '[' + Name + ']';
end;

{ TMsSqlColumns }

function TMsSqlColumns.Add(const AName: string): TMsSqlColumn;
begin
  Result := TMsSqlColumn(inherited Add(AName));
end;

class function TMsSqlColumns.EntityClass: TDbTableMemberClass;
begin
  Result:=TMsSqlColumn;
end;

function TMsSqlColumns.Find(const AColName: string;
  var AColumn: TMsSqlColumn): Boolean;
begin
  Result := inherited Find(AColName, TDbEntity(AColumn));
end;

function TMsSqlColumns.GetItem(Index: Integer): TMsSqlColumn;
begin
  Result := TMsSqlColumn(inherited GetItem(Index));
end;

{ TSqlColType }

function TSqlColType.GetType: Integer;
begin
  Result := Ord(FType);
end;

procedure TSqlColType.SetType(const AType: Integer);
begin
  FType := TMsSqlFieldType(AType);
end;

function TSqlColType.GetName: string;
begin
  Result := uMSSQL_COLTYPE_NAMES[FType];
end;

procedure TSqlColType.SetName(const AName: string);
begin
  FType := ColTypeNameToType(AName);
end;

function TSqlColType.GetIsVariableSize: Boolean;
begin
  Result := DefSize > 0; //FType in VARIABLE_LEN_FIELD_TYPES;
end;

function TSqlColType.GetHasPrecision: Boolean;
begin
  Result := FType in [sftNumeric, sftDecimal];
end;

function TSqlColType.GetDefSize: Integer;
begin
  case FType of
    //sftUnknown         : Result := -1;
    //sftTinyInt         : Result := -1;
    //sftSmallint        : Result := -1;
    //sftInt             : Result := -1;
    sftSysname         : Result := 256;
    sftVarchar         : Result := 50;
    sftNVarchar        : Result := 50;
    sftChar            : Result := 10;
    sftNChar           : Result := 10;
    //sftBigint          : Result := -1;
    //sftBit             : Result := -1;
    sftBinary          : Result := 50;
    sftNBinary         : Result := 50;
    //sftText            : Result := -1;
    //sftNText           : Result := -1;
    //sftSmallDatetime   : Result := -1;
    //sftDate            : Result := -1;
    sftTime            : Result := 7;
    //sftDatetime        : Result := -1;
    sftDateTime2       : Result := 7;
    sftDateTimeOffset  : Result := 7;
    sftDecimal         : Result := 18;
    //sftFloat           : Result := -1;
    //sftSmallMoney      : Result := -1;
    //sftMoney           : Result := -1;
    sftNumeric         : Result := 18;
    sftVarBinary       : Result := 50;
    //sftXml             : Result := -1;
    //sftUniqueIdentifier: Result := -1;
    //sftTimestamp       : Result := -1;
    //sftCustom          : Result := -1;
    else
      Result := -1;
  end;
end;



{ TMsSqlColumn }

constructor TMsSqlColumn.Create(ATable: TDbTable; const AName: string);
begin
  inherited Create(ATable, AName);
  FIdentity := TIdentity.Create;
end;

destructor TMsSqlColumn.Destroy;
begin
  FIdentity.Free;
  inherited;
end;

function TMsSqlColumn.GetColType: TSqlColType;
begin
  Result := TSqlColType(inherited ColType);
end;

class function TMsSqlColumn.GetColTypeClass: TColTypeClass;
begin
  Result := TSqlColType;
end;

function TMsSqlColumn.GetCreateDDL: string;
begin
  Result := GetDDL;
end;

function TMsSqlColumn.GetDDL: string;
var
  vColSize: Integer;
  vColPrec: Integer;
begin
  Result := Format('%s %s', [Fullname, ColType.Name]);
  if ColType.IsVariableSize then
  begin
    vColSize:=Self.Size;
    if vColSize < 1 then
      vColSize := ColType.DefSize;

    if ColType.HasPrecision then
    begin
      vColPrec:=Self.Precision;
      if vColPrec=0 then
        vColPrec:=ColType.DefPrecision;
      Result := Format('%s(%d,%d)', [Result, vColSize, vColPrec]);
    end
    else
      Result := Format('%s(%d)', [Result, vColSize]);
  end;

  if IsIdentity then
    Result := Result + Format(' IDENTITY(%d, %d)', [Self.Identity.Seed, Self.Identity.Increment]);

  if Collation<>'' then
    Result := Result + ' COLLATE ' + Collation;

  if IsNullable then
    Result := Result + ' NULL'
  else
    Result := Result + ' NOT NULL';
end;

function TMsSqlColumn.GetFullname: string;
begin
  Result := '[' + Name + ']';
end;

function TMsSqlColumn.GetIsIdentity: Boolean;
begin
  Result := (ColType.Type_ in [sftTinyInt, sftSmallint, sftInt, sftBigint])
            and FIsIdentity;
end;

procedure TMsSqlColumn.SetIsIdentity(const Value: Boolean);
begin
  FIsIdentity := Value;
end;

{ TIndexCol }

constructor TIndexCol.Create(const AName: string);
begin
  inherited;
  FIsAscending := True;
end;

function TIndexCol.GetCreateDDL: string;
begin
  Result := GetDDL;
end;

function TIndexCol.GetDDL: string;
begin
  Result := Fullname + ' ' + SORT_ORDER_CODES[IsAscending]
end;

function TIndexCol.GetFullname: string;
begin
  Result := '[' + Name + ']';
end;

{ TIndexCols }

class function TIndexCols.EntityClass: TDbEntityClass;
begin
  Result := TIndexCol;
end;

function TIndexCols.GetItem(Index: Integer): TIndexCol;
begin
  Result := TIndexCol(inherited GetItem(Index));
end;

procedure TIndexCols.WriteDdlTo(AStrings: TStrings);
var
  i: Integer;
begin
  for i := 0 to Count-1 do
    AStrings.Add(Items[i].DDL);
end;

{ TDbIndex }

function TMsSqlIndex.GetDDL: string;
var
  i: Integer;
  vCols: TStringList;
begin
  vCols := TStringList.Create;
  try
    case IndexType of
      itUnknown: ;
      itIndex  :
        Result := Format('CREATE %s INDEX %s ON %s'
                         , [CLUSTERED_NAMES[Clustered]
                            , Fullname
                            , Table.Fullname]
                        );
      itPrimary:
        Result := Format('CONSTRAINT [%s] PRIMARY KEY %s', [Name, CLUSTERED_NAMES[Clustered]]);
      itUnique :
        Result := Format('CONSTRAINT [%s] UNIQUE %s', [Name, CLUSTERED_NAMES[Clustered]]);
    end;

    vCols.Clear;
    Cols.WriteDDLs(vCols);
    if vCols.Count > 0 then
    begin
      vCols[0] := '	' + vCols[0];
      for i := 1 to vCols.Count-1 do
        vCols[i] := '	, ' + vCols[i];
    end;
    Result := Result + #13#10'('#13#10 + vCols.Text + ')';

    if Location<>'' then
      Result := Result + Format(' ON [%s]', [Location]);
  finally
    vCols.Free;
  end;
end;

{ TDbIndexes }

function TMsSqlIndexes.Add(const AName: string): TMsSqlIndex;
begin
  Result := TMsSqlIndex(inherited Add(AName));
end;

class function TMsSqlIndexes.EntityClass: TDbTableMemberClass;
begin
  Result := TMsSqlIndex;
end;

function TMsSqlIndexes.GetItem(AIndex: Integer): TMsSqlIndex;
begin
  Result := TMsSqlIndex(inherited GetItem(AIndex));
end;

function TMsSqlIndex.GetFullname: string;
begin
  Result := '[' + Name + ']';
end;

initialization
  CoInitialize(nil);
  InitMsSqlColTypeNames;

finalization
  CoUninitialize;

end.

